perm filename CREF.LSP[LSP,SYS] blob
sn#010444 filedate 1973-07-03 generic text, type T, neo UTF8
(DEFPROP CREFL
(NIL CREFL
CREF
CREF0
CREF1
ALPHA
ALPHA1
ALPHA2
ALPHA3
FTCON
FTCON1
FTCON2
JOIN
REF
DELETE
SETDIFF
TRPEND
SPACES2
POS
LPRINT
XFF
XBLNK
INIT)
VALUE)
(DEFPROP CREF
(LAMBDA(U)
(PROG (V W X)
(SETQ W (CAR U))
(COND
((NOT (EQ W (QUOTE TTY:)))
(OUTC (EVAL (LIST (QUOTE OUTPUT) W (QUOTE FOO))) T)))
(SETQ U (CDR U))
A (COND ((NULL U) (GO END))
((EQUAL (LAST (EXPLODE (CAR U))) (QUOTE (:)))
(GO DEV))
((NULL V) (GO ERR)))
(INC (EVAL (CONS (QUOTE INPUT) (LIST V (CAR U)))))
A1 (COND
((EQ (SETQ X (ERRSET (READ) T)) (QUOTE $EOF$)) (GO D))
((MEMBER (SETQ X (CAR X)) (QUOTE (DEFINE MACRO)))
(MAPCAR (FUNCTION REF) (CAR (READ)))))
(GO A1)
D (INC NIL)
D1 (SETQ U (CDR U))
(GO A)
DEV (SETQ V (CAR U))
(SETQ U (CDR U))
(GO A)
END (INC NIL)
(PRINC XFF)
(CREF0)
(OUTC NIL T)
(RETURN (QUOTE ***))
ERR (OUTC NIL T)
(PRINC (QUOTE ILLEGAL/ DEVICE))
(TERPRI)
(GO D1)))
FEXPR)
(DEFPROP CREF0
(LAMBDA NIL
(PROG NIL
(TERPRI)
(SETQ ALIS NIL)
(ALPHA1)
(CREF1 ALIS)))
EXPR)
(DEFPROP CREF1
(LAMBDA(A)
(PROG (X)
B (COND ((NULL A) (RETURN NIL))
((NULL (SETQ X (GET (CAR A) (QUOTE CNX)))) (GO C)))
(TERPRI)
(PRIN1 (CAR A))
(SPACES2 15)
(PRINC (QUOTE CALLED/ BY))
(LPRINT (ALPHA X) 35)
(GO D)
C (COND ((NULL (GET (CAR A) (QUOTE CALLS))) (GO D)))
(TERPRI)
(PRIN1 (CAR A))
(SPACES2 20)
(PRINC (QUOTE *****/ NOT/ CALLED/ *****))
(TERPRI)
D (SETQ A (CDR A))
(GO B)))
EXPR)
(DEFPROP ALPHA
(LAMBDA(U)
(PROG NIL
(SETQ ALIS NIL)
(MAPCAR (FUNCTION ALPHA2) U)
(RETURN (MAPLIST (FUNCTION CAAR) ALIS))))
EXPR)
(DEFPROP ALPHA1
(LAMBDA NIL
(PROG2 (MAP (FUNCTION
(LAMBDA (J) (MAPCAR (FUNCTION ALPHA3) (CAR J))))
OBLIST)
(SETQ ALIS
(MAPLIST (FUNCTION CAAR) ALIS))))
EXPR)
(DEFPROP ALPHA2
(LAMBDA(U)
(PROG (V W)
(SETQ W
(EXAMINE
(MAKNUM (CAR (GET U (QUOTE PNAME))) (QUOTE FIXNUM))))
(COND ((NULL (SETQ V ALIS)) (RETURN (SETQ ALIS (LIST (CONS U W))))))
A (COND
((LESSP W (CDAR V))
(RETURN
(RPLACA (RPLACD V (CONS (CAR V) (CDR V))) (CONS U W))))
((NULL (CDR V)) (RETURN (NCONC V (LIST (CONS U W))))))
(SETQ V (CDR V))
(GO A)))
EXPR)
(DEFPROP ALPHA3
(LAMBDA (U) (AND (OR (GET U (QUOTE CALLS)) (GET U (QUOTE CNX))) (ALPHA2 U)))
EXPR)
(DEFPROP FTCON
(LAMBDA(U)
(PROG2 (SETQ LVAR (CADR U)) (FTCON2 (FTCON1 (CDDR U)))))
EXPR)
(DEFPROP FTCON1
(LAMBDA(U)
(PROG (V)
A (COND ((NULL U) (RETURN V))
((ATOM (CAR U))
(COND
((MEMBER (CAR U) (QUOTE (PROG LAMBDA)))
(PROG2 (SETQ LVAR (JOIN (CADR U) LVAR))
(SETQ U (CDR U))))
((EQ (CAR U) (QUOTE GO))
(PROG2 (SETQ LVAR (JOIN (CDR U) LVAR)) (RETURN V)))
((NUMBERP (CAR U)) NIL)
((AND (EQ (CAR U) (QUOTE SETQ))
(MEMBER (CADR U) LVAR))
(SETQ U (CDR U)))
((EQ (CAR U) (QUOTE QUOTE)) (RETURN V))
(T (SETQ V (CONS (CAR U) V)))))
(T (SETQ V (JOIN (FTCON1 (CAR U)) V))))
(SETQ U (CDR U))
(GO A)))
EXPR)
(DEFPROP FTCON2
(LAMBDA(V)
(PROG (X Y)
(SETQ Y (JOIN (QUOTE (T NIL)) LVAR))
A (COND ((NULL V) (RETURN X))
((OR (MEMBER (CAR V) Y) (GET (CAR V) (QUOTE NOLIST)))
NIL)
(T (SETQ X (CONS (CAR V) X))))
(SETQ V (CDR V))
(GO A)))
EXPR)
(DEFPROP JOIN
(LAMBDA (A B) (COND ((NULL A) B) ((NULL B) A) (T (TRPEND A B))))
EXPR)
(DEFPROP REF
(LAMBDA(UU)
(PROG (PV1)
(TERPRI)
(COND ((GET (CAR UU) (QUOTE NOLIST)) (RETURN NIL)))
(SETQ PV1 (SETDIFF (FTCON (CADR UU)) LVAR))
(PUTPROP (CAR UU) T (QUOTE CALLS))
(MAPLIST (FUNCTION
(LAMBDA(J)
(PUTPROP (CAR J)
(TRPEND (LIST (CAR UU))
(GET (CAR J) (QUOTE CNX)))
(QUOTE CNX))))
PV1)
(PRIN1 (CAR UU))
(SPACES2 15)
(PRIN1 (QUOTE CALLS))
(COND ((NULL PV1)
(PROG2 (SPACES2 35)
(PRINC (QUOTE *****/ NO/ FUNCTION/ *****))
(TERPRI)))
(T (LPRINT (ALPHA PV1) 35)))))
EXPR)
(DEFPROP DELETE
(LAMBDA(X Y)
(COND ((NULL Y) NIL)
((EQUAL X (CAR Y)) (CDR Y))
(T (CONS (CAR Y) (DELETE X (CDR Y))))))
EXPR)
(DEFPROP SETDIFF
(LAMBDA(X Y)
(COND ((NULL Y) X) (T (SETDIFF (DELETE (CAR Y) X) (CDR Y)))))
EXPR)
(DEFPROP TRPEND
(LAMBDA(U V)
(PROG NIL
A (COND ((NULL U) (RETURN V))
((NOT (MEMBER (CAR U) V)) (SETQ V (CONS (CAR U) V))))
(SETQ U (CDR U))
(GO A)))
EXPR)
(DEFPROP SPACES2
(LAMBDA(V)
(PROG NIL
(COND ((GREATERP (POS) V) (TERPRI)))
(SETQ V (DIFFERENCE V (POS)))
A (COND ((EQ V 0) (RETURN NIL)))
(PRINC XBLNK)
(SETQ V (SUB1 V))
(GO A)))
EXPR)
(DEFPROP POS
(LAMBDA NIL (DIFFERENCE (LINELENGTH NIL) (CHRCT)))
EXPR)
(DEFPROP LPRINT
(LAMBDA(U N)
(PROG NIL
A (SPACES2 N)
B (COND ((NULL U) (RETURN (TERPRI)))
((GREATERP (FLATSIZE (CAR U)) (SUB1 (CHRCT))) (GO C)))
(PRIN1 (CAR U))
(PRINC XBLNK)
(SETQ U (CDR U))
(GO B)
C (TERPRI)
(GO A)))
EXPR)
(DEFPROP XFF
(NIL . /)
VALUE)
(DEFPROP XBLNK
(NIL . / )
VALUE)
(DEFPROP INIT
(LAMBDA NIL
(MAP (FUNCTION
(LAMBDA (J) (PUTPROP (CAR J) (CAR J) (QUOTE NOLIST))))
(QUOTE
(AND ATOM
CAR
CDR
CAAR
CADR
CDAR
CDDR
CAAAR
CAADR
CADAR
CADDR
CDAAR
CDADR
CDDAR
CDDDR
CAAAAR
CAAADR
CAADAR
CAADDR
CADAAR
CADADR
CADDAR
CADDDR
CDAAAR
CDAADR
CDADAR
CDADDR
CDDAAR
CDDADR
CDDDAR
CDDDDR
COND
CONS
EQ
EQUAL
GO
LIST
NOT
NULL
OR
PROG
PROG2
QUOTE
RETURN
FUNCTION))))
EXPR)
(INIT)
(NOUUO NIL)